home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / mitscheme.init < prev    next >
Encoding:
Text File  |  2004-01-06  |  8.2 KB  |  284 lines
  1. ;;;"mitscheme.init" Initialization for SLIB for MITScheme        -*-scheme-*-
  2. ;;; Author: Aubrey Jaffer
  3. ;;;
  4. ;;; This code is in the public domain.
  5.  
  6. ;;; Make this part of your ~/.scheme.init file.
  7.  
  8. (define getenv get-environment-variable)
  9.  
  10. ;;; (software-type) should be set to the generic operating system type.
  11. (define (software-type) (if (getenv "HOMEDRIVE") 'MS-DOS 'UNIX))
  12.  
  13. ;;; (scheme-implementation-type) should return the name of the scheme
  14. ;;; implementation loading this file.
  15.  
  16. (define (scheme-implementation-type) 'MITScheme)
  17.  
  18. ;;; (scheme-implementation-home-page) should return a (string) URL
  19. ;;; (Uniform Resource Locator) for this scheme implementation's home
  20. ;;; page; or false if there isn't one.
  21.  
  22. (define (scheme-implementation-home-page)
  23.   "http://swissnet.ai.mit.edu/scheme-home.html")
  24.  
  25. ;;; (scheme-implementation-version) should return a string describing
  26. ;;; the version the scheme implementation loading this file.
  27.  
  28. (define (scheme-implementation-version)
  29.   (let* ((str (with-output-to-string identify-world))
  30.      (beg (+ (string-search-forward "Release " str) 8))
  31.      (rst (substring str beg (string-length str)))
  32.      (end (string-find-next-char-in-set
  33.            rst
  34.            (predicate->char-set char-whitespace?))))
  35.     (substring rst 0 end)))
  36.  
  37. ;;; (implementation-vicinity) should be defined to be the pathname of
  38. ;;; the directory where any auxillary files to your Scheme
  39. ;;; implementation reside.
  40.  
  41. (define (implementation-vicinity)
  42.   (case (software-type)
  43.     ((MS-DOS)    "c:\\scheme\\")
  44.     ((UNIX)     "/usr/local/lib/mit-scheme/")
  45.     ((VMS)    "scheme$src:")))
  46.  
  47. ;;; (library-vicinity) should be defined to be the pathname of the
  48. ;;; directory where files of Scheme library functions reside.
  49.  
  50. (define library-vicinity
  51.   (let ((library-path
  52.      (or (getenv "SCHEME_LIBRARY_PATH")
  53.          ;; Use this path if your scheme does not support GETENV.
  54.          (case (software-type)
  55.            ((MS-DOS) "c:\\slib\\")
  56.            ((UNIX) "/usr/local/lib/slib/")
  57.            ((VMS) "lib$scheme:")
  58.            (else "")))))
  59.     (lambda () library-path)))
  60.  
  61. ;;; (home-vicinity) should return the vicinity of the user's HOME
  62. ;;; directory, the directory which typically contains files which
  63. ;;; customize a computer environment for a user.
  64.  
  65. (define home-vicinity
  66.   (let ((home-path (getenv "HOME")))
  67.     (lambda () home-path)))
  68.  
  69. ;;; *features* should be set to a list of symbols describing features
  70. ;;; of this implementation.  See Template.scm for the list of feature
  71. ;;; names.
  72.  
  73. (define *features*
  74.       '(
  75.     source                ;can load scheme source files
  76.                     ;(slib:load-source "filename")
  77.     compiled            ;can load compiled files
  78.                     ;(slib:load-compiled "filename")
  79.     rev4-report
  80.     ieee-p1178
  81.     sicp
  82.     rev4-optional-procedures
  83.     rev3-procedures
  84.     rev2-procedures
  85.     multiarg/and-
  86.     multiarg-apply
  87.     rationalize
  88.     object-hash
  89.     delay
  90.     with-file
  91.     string-port
  92.     transcript
  93.     char-ready?
  94.     record
  95.     values
  96.     dynamic-wind
  97.     ieee-floating-point
  98.     full-continuation
  99. ;    sort
  100.     queue
  101.     pretty-print
  102.     object->string
  103.     trace                ;has macros: TRACE and UNTRACE
  104.     defmacro
  105.     compiler
  106.     getenv
  107.     Xwindows
  108.     current-time
  109.     ))
  110.  
  111. (define current-time current-file-time)
  112. (define difftime -)
  113. (define offset-time +)
  114.  
  115. ;;; (OUTPUT-PORT-WIDTH <port>)
  116. (define output-port-width output-port/x-size)
  117.  
  118. ;;; (OUTPUT-PORT-HEIGHT <port>)
  119. (define (output-port-height . arg) 24)
  120.  
  121. ;;; (CURRENT-ERROR-PORT)
  122. (define current-error-port
  123.   (let ((port console-output-port))
  124.     (lambda () port)))
  125.  
  126. ;;; (TMPNAM) makes a temporary file name.
  127. (define tmpnam
  128.   (let ((cntr 100))
  129.     (lambda () (set! cntr (+ 1 cntr))
  130.         (let ((tmp (string-append "slib_" (number->string cntr))))
  131.           (if (file-exists? tmp) (tmpnam) tmp)))))
  132.  
  133. ;;; FORCE-OUTPUT flushes any pending output on optional arg output port.
  134. (define force-output flush-output)
  135. ;;; MITScheme 7.2 is missing flush-output.  Use this instead
  136. ;(define (force-output . arg) #t)
  137.  
  138. ;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string
  139. ;;; port versions of CALL-WITH-*PUT-FILE.
  140. (define (call-with-output-string proc)
  141.   (let ((co (current-output-port)))
  142.     (with-output-to-string
  143.       (lambda ()
  144.     (let ((port (current-output-port)))
  145.       (with-output-to-port co
  146.         (lambda () (proc port))))))))
  147.  
  148. (define (call-with-input-string string proc)
  149.   (let ((ci (current-input-port)))
  150.     (with-input-from-string string
  151.       (lambda ()
  152.     (let ((port (current-input-port)))
  153.       (with-input-from-port ci
  154.         (lambda () (proc port))))))))
  155.  
  156. (define object->string write-to-string)
  157. (define object->limited-string write-to-string)
  158.  
  159. ;;; "rationalize" adjunct procedures.
  160. (define (find-ratio x e)
  161.   (let ((rat (rationalize x e)))
  162.     (list (numerator rat) (denominator rat))))
  163. (define (find-ratio-between x y)
  164.   (find-ratio (/ (+ x y) 2) (/ (- x y) 2)))
  165.  
  166. ;;; CHAR-CODE-LIMIT is one greater than the largest integer which can
  167. ;;; be returned by CHAR->INTEGER.  It is defined incorrectly (65536)
  168. ;;; by MITScheme version 8.0.
  169. (define char-code-limit 256)
  170.  
  171. ;;; MOST-POSITIVE-FIXNUM is used in modular.scm
  172. (define most-positive-fixnum #x03FFFFFF)
  173.  
  174. ;;; Return argument
  175. (define (identity x) x)
  176.  
  177. ;;; SLIB:EVAL is single argument eval using the top-level (user) environment.
  178. ;(define (slib:eval form) (eval form (repl/environment (nearest-repl))))
  179. (define (slib:eval form) (eval form user-initial-environment))
  180.  
  181. (define *macros* '(defmacro))
  182. (define (defmacro? m) (and (memq m *macros*) #t))
  183.  
  184. (syntax-table-define system-global-syntax-table 'defmacro
  185.   (macro defmacargs
  186.     (let ((macname (car defmacargs)) (macargs (cadr defmacargs))
  187.                      (macbdy (cddr defmacargs)))
  188.       `(begin
  189.      (set! *macros* (cons ',macname *macros*))
  190.      (syntax-table-define system-global-syntax-table ',macname
  191.        (macro ,macargs ,@macbdy))))))
  192.  
  193. (define (macroexpand-1 e)
  194.   (if (pair? e) (let ((a (car e)))
  195.           (if (and (symbol? a) (defmacro? a))
  196.               (apply (syntax-table-ref system-global-syntax-table a)
  197.                  (cdr e))
  198.               e))
  199.       e))
  200.  
  201. (define (macroexpand e)
  202.   (if (pair? e) (let ((a (car e)))
  203.           (if (and (symbol? a) (defmacro? a))
  204.               (macroexpand
  205.                (apply (syntax-table-ref system-global-syntax-table a)
  206.                   (cdr e)))
  207.               e))
  208.       e))
  209.  
  210. (define gentemp
  211.   (let ((*gensym-counter* -1))
  212.     (lambda ()
  213.       (set! *gensym-counter* (+ *gensym-counter* 1))
  214.       (string->symbol
  215.        (string-append "slib:G" (number->string *gensym-counter*))))))
  216.  
  217. (define defmacro:eval slib:eval)
  218. (define defmacro:load load)
  219. ;;; If your implementation provides R4RS macros:
  220. ;(define macro:eval slib:eval)
  221. ;(define macro:load load)
  222.  
  223. (define (slib:eval-load <pathname> evl)
  224.   (if (not (file-exists? <pathname>))
  225.       (set! <pathname> (string-append <pathname> (scheme-file-suffix))))
  226.   (call-with-input-file <pathname>
  227.     (lambda (port)
  228.       (let ((old-load-pathname *load-pathname*))
  229.     (set! *load-pathname* <pathname>)
  230.     (do ((o (read port) (read port)))
  231.         ((eof-object? o))
  232.       (evl o))
  233.     (set! *load-pathname* old-load-pathname)))))
  234.  
  235. (define record-modifier record-updater)    ;some versions need this?
  236.  
  237. (define slib:warn
  238.   (lambda args
  239.     (let ((cep (current-error-port)))
  240.       (if (provided? 'trace) (print-call-stack cep))
  241.       (display "Warn: " cep)
  242.       (for-each (lambda (x) (display x cep)) args))))
  243.  
  244. ;; define an error procedure for the library
  245. (define (slib:error . args)
  246.   (if (provided? 'trace) (print-call-stack (current-error-port)))
  247.   (apply error-procedure (append args (list (the-environment)))))
  248.  
  249. ;; define these as appropriate for your system.
  250. (define slib:tab (integer->char 9))
  251. (define slib:form-feed (integer->char 12))
  252.  
  253. (define in-vicinity string-append)
  254.  
  255. ;;; Define SLIB:EXIT to be the implementation procedure to exit or
  256. ;;; return if exitting not supported.
  257. (define slib:exit
  258.   (lambda args
  259.     (cond ((null? args) (exit))
  260.       ((eqv? #t (car args)) (exit))
  261.       ((and (number? (car args)) (integer? (car args))) (exit (car args)))
  262.       (else (exit 1)))))
  263.  
  264. ;;; Here for backward compatability
  265.  
  266. (define (scheme-file-suffix) ".scm")
  267.  
  268. ;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever
  269. ;;; suffix all the module files in SLIB have.  See feature 'SOURCE.
  270.  
  271. (define slib:load-source load)
  272.  
  273. ;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced
  274. ;;; by compiling "foo.scm" if this implementation can compile files.
  275. ;;; See feature 'COMPILED.
  276.  
  277. (define slib:load-compiled load)
  278.  
  279. ;;; At this point SLIB:LOAD must be able to load SLIB files.
  280.  
  281. (define slib:load slib:load-source)
  282.  
  283. (slib:load (in-vicinity (library-vicinity) "require.scm"))
  284.